{-# LANGUAGE TypeOperators              #-}
{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Orca.Prim.Syntax
-- Copyright   :  (c) Stephen Tetley 2013
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- Syntax datatypes and pretty printer.
--
--------------------------------------------------------------------------------

module Orca.Prim.Syntax
  (
    
    Decimal
  , SPair(..)
  , (:::)
  , RateId(..)
  , VarId(..)
  , PrimId
  , primId

  , Orchestra(..)
  , GlobalStmt(..)
  , Instrument(..)
  , LocalDecl(..)
  , Stmt(..)
  , Expr2(..)
  , Expr(..)
  , Value(..)
  , UnaryOp(..)
  , BinOp(..)
  , RelOp(..)

  , ppOrch
    
  ) where

import Orca.Prim.CsoundPP
import Orca.Prim.Utils

import Text.PrettyExprHPJ                   -- package: pretty-expr-hpj

import Text.PrettyPrint.HughesPJ            -- pacakge: pretty
import qualified Text.PrettyPrint.HughesPJ as P


import Data.Fixed
import Data.Monoid


type Decimal = Fixed E9 


-- Strict pair with special constructor syntax

data SPair a b = !a ::: ! b 
  deriving (Eq,Ord,Show)

infixr 4 :::

type (:::) a b = SPair a b


instance (Monoid a, Monoid b) => Monoid (SPair a b) where
  mempty = mempty ::: mempty
  (a1 ::: b1) `mappend` (a2 ::: b2) = (a1 `mappend` a2) ::: (b1 `mappend` b2)



-- | Decl site used to determine when to prefix the var name with
-- a @g@. 
--
data RateId = I_RATE | K_RATE | A_RATE
  deriving (Enum,Eq,Ord,Show)



data VarId = Global  { var_rate  :: RateId
                     , var_name  :: String
                     }
           | Local   { var_rate  :: RateId
                     , var_num   :: Int
                     }
           | DeclVar { var_rate  :: RateId
                     , var_name  :: String
                     }
  deriving (Eq,Ord,Show)



newtype PrimId = PrimId { prim_name   :: String }
  deriving (Eq,Ord,Show)

primId :: String -> PrimId
primId = PrimId


-- | Orchestra
--
data Orchestra = Orchestra
    { orch_globals      :: [GlobalStmt]
    , orch_instrs       :: [Instrument]
    }
  deriving (Eq,Show)

data GlobalStmt = GlobalDecl   VarId PrimId [Expr]
                | GlobalOpCall PrimId [Expr]           -- e.g. ZakInit
  deriving (Eq,Show)


data Instrument = Instrument
    { instr_num         :: Int
    , instr_decls       :: [LocalDecl]
    , instr_body        :: [Stmt]
    }
  deriving (Eq,Show)

data LocalDecl = LocalDecl VarId Expr
  deriving (Eq,Show)


data Stmt = VarDef   VarId  Value                -- ihz = pfield 4
          | SigDef1  VarId  Expr2                -- asig  oscil 440
          | SigDef2  VarId  VarId   Expr2
          | Update   VarId  Expr2
          | OpCallS  PrimId [Expr]
  deriving (Eq,Show)


data Expr2 = Pure Expr
           | OpCallE PrimId  [Expr]
  deriving (Eq,Show)

data Expr = Value Value
          | UnaryE  UnaryOp Expr
          | BinaryE BinOp   Expr Expr
          | RelE    RelOp   Expr Expr
          | CondE   Expr    Expr Expr
          | FunCall PrimId [Expr]
  deriving (Eq,Show)

data Value = Unit
           | Bool Bool
           | Int Int
           | Float Decimal
           | String String
           | Pfield Int
           | Var VarId
  deriving (Eq,Show)


-- | Negation and Bitwise NOT.
--
data UnaryOp = NEG | BNOT
  deriving (Eq,Show)


-- | No power of @(^)@ as its use is discouraged.
--
data BinOp = ADD | SUB | MUL | DIV | LOG_AND | LOG_OR | MODULUS 
  deriving (Enum,Eq,Ord,Show)

data RelOp = EQU | NEQU | LESSTHAN | GREATTHAN | LTEQU | GTEQU
  deriving (Enum,Eq,Ord,Show)


-- | Calling a Opcode is considered effectful. 
-- It is pretty printed as an op-call (no equals sign is 
-- printed).  
--
effectful :: Expr2 -> Bool
effectful (OpCallE {}) = True
effectful _            = False


-- | Identifiers whose type cannot be rendered to Csound 
-- prim-types get name mangled.
--
varName :: VarId -> String
varName (Global _ ss)    = ss
varName (Local ri i)     = rateName ri : 'Z' : show i
varName (DeclVar _ ss)   = ss

rateName :: RateId -> Char
rateName I_RATE = 'i'
rateName K_RATE = 'k'
rateName A_RATE = 'a'


--------------------------------------------------------------------------------
-- Pretty print

ppOrch :: Orchestra -> Doc
ppOrch (Orchestra gbls insts) = 
    gbls_doc $+$ blank_doc $+$ insts_doc
  where
    insts_doc = vcat $ map (\x -> ppInstr x $+$ blank_doc) insts
    gbls_doc  = vcat $ map ppGlobalStmt gbls

ppGlobalStmt :: GlobalStmt -> Doc
ppGlobalStmt (GlobalDecl vid pid es)  = text (varName vid) <+> opCall pid es
ppGlobalStmt (GlobalOpCall pid es)    = opCall pid es


ppInstr :: Instrument -> Doc
ppInstr (Instrument i decls body) = 
        text "instr" <+> int i
    $+$ nest 2 (vcat $ map ppLocalDecl decls)
    $+$ nest 2 (ppStmts body)
    $+$ text "endin"

ppLocalDecl :: LocalDecl -> Doc
ppLocalDecl (LocalDecl vid e)   = equalsLine vid $ ppExpr e

ppStmts :: [Stmt] -> Doc
ppStmts []     = empty
ppStmts [x]    = ppStmt x
ppStmts (x:xs) = ppStmt x $+$ ppStmts xs

ppStmt :: Stmt -> Doc
ppStmt (VarDef v val)           = equalsLine v $ ppValue val
ppStmt (SigDef1 v e)            = expr2Line v e
ppStmt (SigDef2 v1 v2 e)        = 
    commaSep (map ppVarId [v1,v2]) <+> nest 12 (ppExpr2 e)

ppStmt (Update v e)             = expr2Line v e
ppStmt (OpCallS s xs)           = opCall s xs


expr2Line :: VarId -> Expr2 -> Doc
expr2Line v e
    | effectful e               = effectLine v $ ppExpr2 e
    | otherwise                 = equalsLine v $ ppExpr2 e

effectLine :: VarId -> Doc -> Doc
effectLine vid d = padTextR 11 (varName vid) <+> d

equalsLine :: VarId -> Doc -> Doc
equalsLine vid d = padTextR 11 (varName vid) <+> equals <+> d

ppVarId :: VarId -> Doc
ppVarId = text . varName



ppExpr2 :: Expr2 -> Doc
ppExpr2 (OpCallE s xs)       = opCall s xs
ppExpr2 (Pure e)             = ppExpr e

ppExpr :: Expr -> Doc
ppExpr = unparse . exprDocE

exprDocE :: Expr -> DocE
exprDocE (Value v)            = Atom $ ppValue v
exprDocE (UnaryE op e)        = unaryDocE op (exprDocE e)
exprDocE (BinaryE op e1 e2)   = binDocE op (exprDocE e1) (exprDocE e2)
exprDocE (RelE op e1 e2)      = relDocE op (exprDocE e1) (exprDocE e2)
exprDocE (FunCall pid es)     = 
    Atom $ text (prim_name pid) P.<> tupled (map ppExpr es)

exprDocE (CondE ce e1 e2)     = 
    Atom $ parens (ppExpr ce <+> char '?'   <+> ppExpr e1
                             <+> char ':'   <+> ppExpr e2 )

opCall :: PrimId -> [Expr] -> Doc
opCall s xs = text (prim_name s) <+> commaSep (map ppExpr xs)

ppValue :: Value -> Doc
ppValue (Unit)        = text "()"
ppValue (Bool True)   = int 1  
ppValue (Bool False)  = int 0
ppValue (Int i)       = int i
ppValue (Float d)     = truncatedDouble $ realToFrac d
ppValue (String ss)   = doubleQuotes $ text ss
ppValue (Pfield i)    = text $ 'p' : show i
ppValue (Var v)       = text $ varName v 



unaryDocE :: UnaryOp -> DocE -> DocE
unaryDocE NEG   = negateU
unaryDocE BNOT  = bitwiseNotU


binDocE :: BinOp -> DocE -> DocE -> DocE
binDocE ADD         = addB
binDocE SUB         = subtractB
binDocE MUL         = multiplyB
binDocE DIV         = divideB
binDocE LOG_AND     = logicalAndB
binDocE LOG_OR      = logicalOrB
binDocE MODULUS     = moduloB


relDocE :: RelOp -> DocE -> DocE -> DocE
relDocE EQU         = equalB
relDocE NEQU        = notEqualB
relDocE LESSTHAN    = lessThanB
relDocE GREATTHAN   = greaterThanB
relDocE LTEQU       = lessThanEqB
relDocE GTEQU       = greaterThanEqB

